home *** CD-ROM | disk | FTP | other *** search
/ Programmer Plus 2007 / Programmer-Plus-2007.iso / Programming / Borland Plateform / TURBO PASCAL 1.5 for WIN / RWDEMOS.PAK / RWPDEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-06-08  |  13.5 KB  |  442 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Resource Workshop Demo                       }
  5. {   Copyright (c) 1992 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. {
  10.    This example can be compiled with either the
  11.    "standard" windows look or the "Borland look".
  12.    By default, it uses "standard" windows controls.
  13.    To cause it to use Borland Windows Custom Controls,
  14.    select Options.Compiler and enter BWCC in the
  15.    Conditional defines field.
  16. }
  17.  
  18.  
  19. program RWPDemo;
  20.  
  21. {$ifdef BWCC}
  22. {$R RWPDEMOB.RES}
  23. {$else}
  24. {$R RWPDEMO.RES}
  25. {$endif}
  26. {$D 'Resource Workshop Demo Program. Copyright (c) Borland 1992'}
  27.  
  28. uses
  29.      WinTypes, WinProcs,
  30.      WObjects,
  31.      {$ifdef BWCC}
  32.      BWCC,
  33.      {$endif}
  34.      Strings,  RWPDemoC, RWPDlgs,
  35.      RWPWnd, WinDOS;
  36.  
  37. const
  38.   AppName = 'RWPDEMO';
  39.   StatusLineHeight        =  20;
  40.   TextStart               = 200; { Location for hints in status line }
  41.   EditFirst               = cm_EditUndo;
  42.   EnvironmentFirst        = cm_Preferences;
  43.   FileFirst               = cm_New;
  44.   Helpfirst               = cm_Index;
  45.   OptionFirst             = cm_Directories;
  46.   ViewFirst               = cm_All;
  47.   WindowFirst             = cm_TileChildren;
  48.   am_DrawStatusLine       = wm_User + 200;
  49.  
  50. type
  51.   PRWPApplication = ^RWPApplication;
  52.   RWPApplication = object(TApplication)
  53.     constructor Init(AName: PChar);
  54.     procedure InitMainWindow; virtual;
  55.     procedure Error(ErrorCode: Integer); virtual;
  56.   end;
  57.  
  58. type
  59.   PRWPWindow = ^TRWPWindow;
  60.   TRWPWindow = object(TMDIWindow)
  61.     BmpStatusBar: HBitmap;
  62.     BmpStatusLine: HBitmap;
  63.     CurrentID: Word;
  64.     CurrentPopup: HMenu;
  65.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  66.     destructor  Done; virtual;
  67.     procedure AboutRWP(var Msg: TMessage); virtual cm_First + cm_About_RWP;
  68.     procedure BlastStatusLine(PaintDC: HDC);
  69.     procedure ReconstructStatusLine;
  70.     procedure DefCommandProc(var Msg: TMessage); virtual;
  71.     procedure FileNew(var Msg: TMessage); virtual cm_First + cm_New;
  72.     procedure FileOpen(var Msg: TMessage); virtual cm_First + cm_Open;
  73.     procedure FilePrint(var Msg: TMessage); virtual cm_First + cm_Print;
  74.     function  GetClassName: PChar; virtual;
  75.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  76.     procedure OpenAFile(FileType: Integer; FileName: PChar);
  77.     procedure OptionsDirectories(var Msg: TMessage); virtual cm_First+cm_Directories;
  78.     procedure OptionsMouse(var Msg: TMessage); virtual cm_First+cm_Mouse;
  79.     procedure OptionsOpen(var Msg: TMessage); virtual cm_First+cm_Options_Open;
  80.     procedure OptionsPreferences(var Msg: TMessage); virtual cm_First+cm_Preferences;
  81.     procedure OptionsSave(var Msg: TMessage); virtual cm_First+cm_Options_Save;
  82.     procedure OptionsSaveAs(var Msg: TMessage); virtual cm_First+cm_Options_Saveas;
  83.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  84.     procedure StubDialog(ADialog: PRWPDialog; ACaption: PChar);
  85.     procedure WMDrawStatusLine(var Msg: TMessage); virtual wm_First + am_DrawStatusLine;
  86.     procedure WMMenuSelect(var Msg: TMessage); virtual wm_First + wm_MenuSelect;
  87.     procedure WMEnterIdle(var Msg: TMessage); virtual wm_First + wm_EnterIdle;
  88.     procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
  89.   end;
  90.  
  91. {------------------------- TRWPApplication implementation ---------------}
  92.  
  93. constructor RWPApplication.Init(AName: PChar);
  94. begin
  95.   TApplication.Init(AName);
  96.   HAccTable := LoadAccelerators(HInstance, MakeIntResource(Acc_Main));
  97. end;
  98.  
  99.  
  100. procedure RWPApplication.InitMainWindow;
  101. begin
  102.   MainWindow := New(PRWPWindow, Init(nil, 'Resource Workshop Demo Program'));
  103. end;
  104.  
  105. procedure RWPApplication.Error(ErrorCode: Integer);
  106. var
  107.   Title: array [0..40] of char;
  108.   Msg: array [0..80] of char;
  109. begin
  110.   if (ErrorCode > 0) and
  111.      (LoadString(HInstance, ErrorCode, Msg, SizeOf(Msg)) > 0) and
  112.      (LoadString(HInstance, ErrorCode+1, Title, SizeOf(Title)) > 0) then
  113.     MessageBox(0, Msg, Title, mb_IconExclamation or mb_OK)
  114.   else
  115.     TApplication.Error(ErrorCode);
  116. end;
  117.  
  118.  
  119. {--------------------------- TRWPWindow implementation ------------------}
  120.  
  121. constructor TRWPWindow.Init(AParent:PWIndowsObject; ATitle:PChar);
  122. begin
  123.   TMDIWindow.Init('RWP Application', LoadMenu(HInstance,
  124.     MakeIntResource(men_Main)));
  125.   BmpStatusBar := LoadBitmap(HInstance, MakeIntResource(bmp_StatusBar));
  126.   BmpStatusLine := 0;
  127. end;
  128.  
  129. procedure TRWPWindow.AboutRWP(var Msg:TMessage);
  130. begin
  131.   Application^.ExecDialog(New(PRWPDialog, Init(@Self, MakeIntResource(dlg_About))));
  132. end;
  133.  
  134. procedure TRWPWindow.BlastStatusLine(PaintDC: HDC);
  135. var
  136.   ClientRect: TRect;
  137.   MemDC: HDC;
  138.   OldBmp: THandle;
  139. begin
  140.   GetClientRect(HWindow, ClientRect);
  141.   MemDC := CreateCompatibleDC(PaintDC);
  142.   OldBmp := SelectObject(MemDC, BmpStatusLine);
  143.   with ClientRect do
  144.     BitBlt(PaintDC, 0, Bottom - StatusLineHeight, ClientRect.Right,
  145.       StatusLineHeight, MemDC, 0, 0, SrcCopy);
  146.   SelectObject(MemDC, OldBmp);
  147.   DeleteDC(MemDC);
  148. end;
  149.  
  150. procedure TRWPWindow.DefCommandProc(var Msg: TMessage);
  151. var
  152.   DC: HDC;
  153. begin
  154.   TMDIWindow.DefCommandProc(Msg);
  155.   if CurrentPopup <> 0 then
  156.   begin
  157.     CurrentPopup := 0;
  158.     CurrentID := 0;
  159.     DC := GetDC(HWindow);
  160.     BlastStatusLine(DC);
  161.     ReleaseDC(HWindow, DC);
  162.   end;
  163. end;
  164.  
  165. destructor TRWPWindow.Done;
  166. begin
  167.   DeleteObject(BmpStatusLine);
  168.   DeleteObject(BmpStatusBar);
  169.   TMDIWindow.Done;
  170. end;
  171.  
  172. procedure TRWPWindow.FileNew(var Msg:TMessage);
  173. var
  174.   FileName: array[0..128] of Char;
  175.   FileType: Integer;
  176. begin
  177.   if Application^.ExecDialog(New(PFileNew,
  178.     Init(@Self, FileType))) = id_OK then OpenAFile(FileType, nil)
  179. end;
  180.  
  181. procedure TRWPWindow.FileOpen(var Msg:TMessage);
  182. var
  183.   FileName: array[0..128] of Char;
  184.   FileType: Integer;
  185. begin
  186.   FillChar(Filename, sizeof(FileName), #0);
  187.   StrCopy(Filename, '*.txt');
  188.   FileType := FileWindow;
  189.   if Application^.ExecDialog(New(PFileOpen,
  190.     Init(@Self, FileType, FileName))) = id_OK then
  191.     OpenAFile(FileType,FileName)
  192. end;
  193.  
  194. procedure TRWPWindow.FilePrint(var Msg:TMessage);
  195. begin
  196.   StubDialog(New(PRWPDialog, Init(@Self,MakeIntResource(dlg_Print))),'Print');
  197. end;
  198.  
  199. function TRWPWindow.GetClassName: PChar;
  200. begin
  201.   GetClassName := 'RWPWindow';
  202. end;
  203.  
  204. procedure TRWPWindow.GetWindowClass(var WndClass: TWndClass);
  205. begin
  206.   TMDIWindow.GetWindowClass(WndClass);
  207.   WndClass.HIcon := LoadIcon(HInstance, MakeIntResource(ico_RWPDemo));
  208.   WndClass.HBrBackground := color_AppWorkspace + 1;
  209. end;
  210.  
  211. procedure TRWPWindow.OpenAFile(FileType: Integer; FileName: PChar);
  212. begin
  213.   with PRWPApplication(Application)^ do
  214.     case FileType of
  215.       ScribbleWindow:
  216.         MakeWindow(new(PScribbleWindow, Init(@Self, FileName)));
  217.       FileWindow:
  218.         MakeWindow(new(PEditWindow, Init(@Self, FileName)));
  219.       GraphWindow:
  220.         MakeWindow(new(PGraphWindow, Init(@Self, FileName)));
  221.     end;
  222. end;
  223.  
  224. procedure TRWPWindow.OptionsDirectories(var Msg:TMessage);
  225. begin
  226.   StubDialog(new(PDlgDirectories,
  227.     Init(@Self, MakeIntResource(dlg_Options_Directories))), 'Directories');
  228. end;
  229.  
  230. procedure TRWPWindow.OptionsMouse(var Msg:TMessage);
  231. begin
  232.   StubDialog(new(PRWPDialog,
  233.     Init(@Self, MakeIntResource(dlg_MouseDialog))), 'Mouse');
  234. end;
  235.  
  236. procedure TRWPWindow.OptionsOpen(var Msg:TMessage);
  237. begin
  238.   StubDialog(new(PRWPDialog,
  239.     Init(@Self, MakeIntResource(dlg_Options_Open))), 'Options Open');
  240. end;
  241.  
  242. procedure TRWPWindow.OptionsPreferences(var Msg:TMessage);
  243. begin
  244.   StubDialog(new(PRWPDialog,
  245.     Init(@Self, MakeIntResource(dlg_Preferences))), 'Preferences');
  246. end;
  247.  
  248. procedure TRWPWindow.OptionsSave(Var Msg: TMessage);
  249. begin
  250.   MessageBox(HWindow, 'Feature not implemented', 'Options Save', mb_OK);
  251. end;
  252.  
  253. procedure TRWPWindow.OptionsSaveAs(var Msg:TMessage);
  254. begin
  255.   StubDialog(new(PRWPDialog,
  256.     Init(@Self,MakeIntResource(dlg_Options_SaveAs))), 'Options SaveAs');
  257. end;
  258.  
  259. procedure TRWPWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  260. begin
  261.   TMDIWindow.Paint(PaintDC, PaintInfo);
  262.   BlastStatusLine(PaintDC);
  263. end;
  264.  
  265. procedure TRWPWindow.StubDialog(ADialog: PRWPDialog; ACaption: PChar);
  266. begin
  267.   if Application^.ExecDialog(ADialog) = id_Ok then
  268.     MessageBox(HWindow, 'Feature not implemented', ACaption, mb_OK);
  269. end;
  270.  
  271. procedure TRWPWindow.WMDrawStatusLine(var Msg: TMessage);
  272. var
  273.   DC: HDC;
  274.   Rect: TRect;
  275.   Str: array[0..128] of Char;
  276.   StrID: Integer;
  277.   Lf: TLogFont;
  278.   hSmall, hOld: HFont;
  279.   TextHeight: Integer;
  280. begin
  281.   if CurrentID <> 0 then
  282.   begin
  283.     case CurrentID of
  284.       cm_New: StrID := sth_FileNew;
  285.       cm_Open: StrID := sth_FileOpen;
  286.       cm_Save: StrID := sth_FileSave;
  287.       cm_SaveAs: StrID := sth_FileSaveAs;
  288.       cm_Print: StrID := sth_FilePrint;
  289.       cm_Exit: StrID := sth_FileExit;
  290.       cm_EditUndo: StrID := sth_EditUndo;
  291.       cm_EditCut: StrID := sth_EditCut;
  292.       cm_EditCopy: StrID := sth_EditCopy;
  293.       cm_EditPaste: StrID := sth_EditPaste;
  294.       cm_EditDelete: StrID := sth_EditDelete;
  295.       cm_EditClear: StrID := sth_EditClear;
  296.       cm_Options_Open: StrID := sth_OptionsOpen;
  297.       cm_all: StrID := sth_ViewAll;
  298.       cm_By: StrID := sth_ViewBy;
  299.       cm_Some: StrID := sth_ViewSome;
  300.       cm_Directories: StrID := sth_OptionsDirectory;
  301.       cm_Options_Save: StrID := sth_OptionsSave;
  302.       cm_Options_SaveAs: StrID := sth_OptionsSaveAs;
  303.       cm_Preferences: StrID := sth_EnvironmentPreferences;
  304.       cm_Mouse: StrID := sth_EnvironmentMouse;
  305.       cm_TileChildren: StrID := sth_WindowTile;
  306.       cm_CascadeChildren: StrID := sth_WindowCascade;
  307.       cm_ArrangeIcons: StrID := sth_WindowArrange;
  308.       cm_CloseChildren: StrID := sth_WindowCloseAll;
  309.       cm_Index: StrID := sth_HelpIndex;
  310.       cm_Topic_Search: StrID := sth_HelpTopic;
  311.       cm_Glossary: StrID := sth_HelpGlossary;
  312.       cm_Using_Help: StrID := sth_HelpUsing;
  313.       cm_About_RWP: StrID := sth_HelpAbout;
  314.       else
  315.         Exit;
  316.     end
  317.   end
  318.   else
  319.   if CurrentPopup <> 0 then
  320.   begin
  321.     case GetMenuItemID(CurrentPopup, 0) of
  322.       FileFirst: StrID := sth_File;
  323.       EditFirst: StrID := sth_Edit;
  324.       ViewFirst: StrID := sth_View;
  325.       WindowFirst: StrID := sth_Window;
  326.       OptionFirst: StrID := sth_Option;
  327.       EnvironmentFirst: StrID := sth_OptionsEnvironment;
  328.       HelpFirst: StrID := sth_Help;
  329.       else
  330.         Exit;
  331.     end;
  332.   end;
  333.  
  334.   DC := GetDC(HWindow);
  335.   BlastStatusLine(DC);
  336.   if (CurrentPopup <> 0) or (CurrentID <> 0) then
  337.   begin
  338.     hOld := SelectObject(DC, GetStockObject(ANSI_VAR_FONT));
  339.     LoadString(HInstance, StrID, Str, Sizeof(Str));
  340.     GetClientRect(HWindow, Rect);
  341.     SetBKColor(DC, RGB(192, 192, 192));
  342.     TextHeight :=  HiWord( GetTextExtent( DC, Str, 1) );
  343.     TextOut(DC, TextStart+10,
  344.       Rect.bottom - StatusLineHeight + ( ( StatusLineHeight - TextHeight ) div 2),
  345.       Str, strlen(Str));
  346.     SelectObject(DC, hOld);
  347.   end;
  348.   ReleaseDC(HWindow, DC);
  349. end;
  350.  
  351. procedure TRWPWindow.WMMenuSelect(var Msg: TMessage);
  352. var
  353.   CurrentMenu: HWnd;
  354.   Str: array[0..20] of Char;
  355. begin
  356.   if Msg.LParamLo = $FFFF then
  357.   begin
  358.     CurrentPopup := 0;
  359.     CurrentID := 0;
  360.   end
  361.   else
  362.   if (Msg.LParamLo and mf_Popup) <> 0 then
  363.   begin
  364.    CurrentPopup := Msg.WParam;
  365.     CurrentID := 0;
  366.   end
  367.   else
  368.     CurrentID := Msg.WParam;
  369.   PostMessage(HWindow,am_DrawStatusLine, 0, 0);
  370. end;
  371.  
  372. procedure TRWPWindow.WMEnterIdle(var Msg: TMessage);
  373. { If the user pressed the F1 key, and a Dialog box is active (and idle), send
  374.   an ID_Help message to the dialog, to get the behavior associated with
  375.   pressing the help button in that dialog }
  376. begin
  377.  if ( Msg.WParam = Msgf_DialogBox) and ( ( GetKeyState( Vk_F1) and $8000) <> 0) then
  378.    SendMessage( Msg.LParamLo, wm_Command, Id_Help, 0);
  379. end;
  380.  
  381. procedure TRWPWindow.WMSize(var Msg: TMessage);
  382. var
  383.   Rect: TRect;
  384. begin
  385.   TMDIWindow.WMSize(Msg);
  386.   GetClientRect(HWindow, Rect);
  387.   SetWindowPos(ClientWnd^.HWindow, 0, 0, 0, Rect.Right,
  388.     Rect.Bottom - StatusLineHeight, swp_NoZOrder);
  389.   ReconstructStatusLine;
  390. end;
  391.  
  392. procedure TRWPWindow.ReconstructStatusLine;
  393. var
  394.   Bmp: HBitmap;
  395.   DC: HDC;
  396.   DestDC: HDC;
  397.   OldSrc: HBitmap;
  398.   OldDest: HBitmap;
  399.   Rect: TRect;
  400.   SrcDC: HDC;
  401. begin
  402.   GetClientRect(HWindow, Rect);
  403.   DC := GetDC(HWindow);
  404.   SrcDC := CreateCompatibleDC(DC);
  405.   DestDC := CreateCompatibleDC(DC);
  406.   ReleaseDC(HWindow, DC);
  407.  
  408.   Bmp := LoadBitmap(HInstance, MakeIntResource(bmp_StatusLine));
  409.   OldSrc := SelectObject(SrcDC, Bmp);
  410.   if BmpStatusLine <> 0 then
  411.     DeleteObject(BmpStatusLine);
  412.   BmpStatusLine := CreateCompatibleBitmap(DC, Rect.Right, StatusLineHeight);
  413.   OldDest := SelectObject(DestDC, BmpStatusLine);
  414.   BitBlt(DestDC, 0, 0, 5, StatusLineHeight, SrcDC, 0, 0, srcCopy);
  415.   StretchBlt(DestDC, 5, 0, Rect.Right - 5, StatusLineHeight,
  416.              SrcDC, 6, 0, 20, StatusLineHeight, srcCopy);
  417.   BitBlt(DestDC, Rect.Right - 5, 0, 5, StatusLineHeight, SrcDC, 59, 0, srcCopy);
  418.  
  419.   SelectObject(SrcDC, BmpStatusBar);
  420.   BitBlt(DestDC, 40, 0, 10, StatusLineHeight,
  421.          SrcDC, 0, 0, SrcCopy);
  422.   BitBlt(DestDC, 100, 0, 10, StatusLineHeight,
  423.          SrcDC, 0, 0, SrcCopy);
  424.   BitBlt(DestDC, TextStart, 0, 10, StatusLineHeight,
  425.          SrcDC, 0, 0, SrcCopy);
  426.  
  427.   SelectObject(SrcDC, OldSrc);
  428.   BmpStatusLine := SelectObject(DestDC, OldDest);
  429.   DeleteDC(SrcDC);
  430.   DeleteDC(DestDC);
  431.   DeleteObject(Bmp);
  432. end;
  433.  
  434. var
  435.   RWPApp:RWPApplication;
  436.  
  437. begin
  438.   RWPApp.Init(AppName);
  439.   RWPApp.Run;
  440.   RWPApp.Done;
  441. end.
  442.